X - function and predicate with the same name (and different or same
X adicity)
X - function or predicate with the same name as a target
X - zeroadic and monadic unit with the same name
X - zeroadic and dyadic unit with the same name.
X*/
X
X#define CR_EXIST MESS(4005, "there is already a how-to with this name")
X
X#define CR_TAR MESS(4006, "there is already a permanent location with this name")
X
X#define ED_EXIST MESS(4007, "*** the how-to name is already in use;\n*** should the old how-to be discarded?\n*** (if not you have to change the how-to name)\n")
X
X#define ED_TAR MESS(4008, "*** the how-to name is already in use for a permanent location;\n*** should that location be deleted?\n*** (if not you have to change the how-to name)\n")
X
X/* name_conflict() is called if a unit is created (HOW TO ? : command) */
X
XHidden bool name_conflict(pname) value pname; {
X value npname;
X if (smash(pname, &npname)) {
X interr(Permtype(npname) == Tar ? CR_TAR : CR_EXIST);
X if (Permtype(pname) != Tar)
X def_perm(last_unit, npname);
X release(npname);
X return Yes;
X }
X return No;
X}
X
X/* name_clash() is called if a unit is edited through the ':' command */
X
XHidden bool name_clash(pname) value pname; {
X value npname;
X
X if (!Valid(pname))
X return No;
X while (smash(pname, &npname)) {
X if (!do_discard(npname)) {
X release(npname);
X return Yes;
X }
X /* continue: there can be both a monadic and a */
X /* dyadic version */
X release(npname); npname= Vnil;
X }
X return No;
X}
X
XHidden bool do_discard(pname) value pname; {
X bool istarg= Permtype(pname) == Tar;
X
X if (is_intended(istarg ? ED_TAR : ED_EXIST)) {
X if (istarg) {
X value name= Permname(pname);
X del_target(name);
X release(name);
X }
X else {
X free_unit(pname);
X del_perm(pname);
X }
X return Yes;
X }
X return No;
X}
X
XHidden bool smash(pname, npname) value pname, *npname; {
X/* Edit a unit. The name of the unit is either given, or is defaulted
X to the last unit edited or the last unit that gave an error, whichever
X was most recent.
X It is possible for the user to mess things up with the w command, for
X instance, but this is not checked. It is allowed to rename the unit though,
X or delete it completely. If the file is empty, the unit is disposed of.
X Otherwise, the name and adicity are determined and if these have changed,
X the new unit is written out to a new file, and the original deleted.
X Thus the original is not saved.
X
X The function edit_unit parses the command line and does some
X high-level bookkeeping; ed_unit does the lower-level bookkeeping;
X f_edit is called to pass control to the editor and wait till it
X finishes its job. Note that the editor reads the unit from the file
X and writes it back (if changed); there is no sharing of data
X structures such as parse trees in this version of the system.
X
X Renaming, deleting, or changing the adicity of a test or yield
X unfortunately requires all other units to be thrown away internally
X (by freeunits), since the unit parse trees may be wrong. For instance,
X consider the effect on the following of making a formerly monadic
X function f, into a zeroadic function:
X WRITE f root 2
X*/
X
X#define CANT_EDIT MESS(4009, "I find nothing editible here")
X
XVisible value last_unit= Vnil;
X
XVisible Procedure edit_unit() {
X value name= Vnil, pname= Vnil;
X value fname, *aa;
X value which_funprd();
X char *kw;
X
X if (Ceol(tx)) {
X if (!p_exists(last_unit, &aa))
X parerr(MESS(4010, "no current how-to"));
X else pname= copy(*aa);
X }
X else if (is_cmdname(ceol, &kw)) {
X name= mk_text(kw);
X pname= permkey(name, Cmd);
X }
X else if (is_tag(&name))
X pname= which_funprd(name);
X else
X parerr(CANT_EDIT);
X
X if (still_ok && ens_filed(pname, &fname)) {
X ed_unit(&pname, &fname, No);
X release(fname);
X }
X release(name); release(pname);
X}
X
X#define ED_MONDYA MESS(4011, "*** do you want to visit the version with %c or %c operands?\n")
X#define ONE_PAR '1'
X#define TWO_PAR '2'
X
XHidden value which_funprd(name) value name; {
X /* There may be two units with the same name (functions
X or predicates of different adicity). Check if this
X is the case, and if so, ask which one is meant.
X */
X value pname, v= Vnil;
X char qans;
X
X if (p_version(name, Zfd, &pname) || p_version(name, Zpd, &pname))
X return pname;
X if (p_version(name, Mfd, &pname) || p_version(name, Mpd, &pname)) {
X if (p_version(name, Dfd, &v) || p_version(name, Dpd, &v)) {
X qans= q_answer(ED_MONDYA, ONE_PAR, TWO_PAR);
X if (qans == ONE_PAR) {
X release(v);
X return pname;
X }
X else if (qans == TWO_PAR) {
X release(pname);
X return copy(v);
X }
X else {
X /* interrupted */
X still_ok = No;
X return pname;
X }
X }
X else {
X release(v);
X return pname;
X }
X }
X if (p_version(name, Dfd, &pname))
X return pname;
X if (p_version(name, Dpd, &pname))
X return pname;
X
X /* be prepared to find at least one not-filed how-to;
X * this does not find all of them;
X * and it doesn't allow any conflicting with already existing ones.
X */
X
X if (u_version(name, Zfd, &pname) ||
X u_version(name, Mfd, &pname) ||
X u_version(name, Dfd, &pname) ||
X u_version(name, Zpd, &pname) ||
X u_version(name, Mpd, &pname) ||
X u_version(name, Dpd, &pname)
X )
X return pname;
X
X return permkey(name, Dpd);
X /* If it doesn't exist, ens_filed will complain. */
X}
X
X#define NO_U_WRITE MESS(4012, "*** you have no write permission in this workspace:\n*** you may not change the how-to\n*** do you still want to display the how-to?\n")
X
X/* Edit a unit. Parameters are the prmnv key and the file name.
X This is called in response to the ':' command and when a new unit is
X created (the header of the new unit must already be written to the
X file).
X Side effects are many, e.g. on prmnv: the unit may be deleted or
X renamed. When renamed, the original unit is lost.
X The unit is reparsed after editing. A check is made for illegal
X name conflicts (e.g., a zeroadic and a monadic unit of the same
X name), and this is resolved by forcing the user to edit the unit
X again. In that case the edit is done on a temporary file.
X The new unit name is kept as the current unit name; when the unit is
X deleted the current unit name is set to Vnil. */
XHidden Procedure tarfiled(name, v) value name, v; {
X value p= mk_indirect(v);
X def_target(name, p);
X release(p);
X}
X
XVisible value last_target= Vnil; /* last edited target */
X
XVisible Procedure del_target(name) value name; {
X value pname= permkey(name, Tar);
X value *aa;
X free_target(name);
X del_perm(pname);
X if (p_exists(last_target, &aa) && (compare(name, *aa) == 0))
X free_perm(last_target);
X release(pname);
X}
X
XHidden value get_tfname(name) value name; {
X value fname;
X value pname= permkey(name, Tar);
X value *aa;
X
X if (p_exists(pname, &aa))
X fname= copy(*aa);
X else {
X fname= new_fname(name, Tar);
X if (Valid(fname))
X def_perm(pname, fname);
X else
X interrV(CANTGETFNAME, name);
X }
X release(pname);
X return fname;
X}
X
XVisible Procedure edit_target() {
X value name= Vnil;
X value fname, *aa;
X if (Ceol(tx)) {
X if (!p_exists(last_target, &aa))
X parerr(MESS(4016, "no current location"));
X else
X name= copy(*aa);
X } else if (!is_tag(&name))
X parerr(CANT_EDIT);
X if (still_ok && ens_tfiled(name, &fname)) {
X ed_target(name, fname);
X release(fname);
X }
X release(name);
X}
X
X#define NO_T_WRITE MESS(4017, "*** you have no write permission in this workspace:\n*** you may not change the location\n*** do you still want to display the location?\n")
X
X/* Edit a target. The value in the target is written to the file,
X and then removed from the internal permanent environment so that
X if a syntax error occurs when reading the value back, the value is
X absent from the internal permanent environment.
X Thus when editing the file to correct the syntax error, the
X file doesn't get overwritten.
X The contents may be completely deleted in which case the target is
X deleted. */
X
XHidden Procedure ed_target(name, fname) value name, fname; {
X value v;
X
X#ifdef CK_WS_WRITABLE
X if (!wsp_writable() && !is_intended(NO_T_WRITE)) return;
X#endif
X#ifdef CLEAR_MEM
X clear_perm(); /* To give the editor as much space as possible */
X#endif
X def_perm(last_target, name);
X if (!f_edit(fname, 0, '=', No))
X /* File is unchanged */
X return;
X if (!still_there(fname)) {
X del_target(name);
X#ifdef SAVE_PERM
X put_perm(b_perm);
X#endif
X return;
X }
X fclose(ifile); /* Since still_there leaves it open */
X /* vs_ifile(); ? */
X v= getval(fname, In_edval);
X if (still_ok) def_target(name, v);
X release(v);
X}
X
X#define NO_TARGET MESS(4018, "%s isn't a location in this workspace")
X
XVisible bool ens_tfiled(name, fname) value name, *fname; {
X value *aa;
X if (!t_exists(name, &aa)) {
X pprerrV(NO_TARGET, name);
X return No;
X } else {
X *fname= get_tfname(name);
X if (!Valid(*fname))
X return No;
X if (!Is_filed(*aa)) {
X release(errtname); errtname= copy(name);
X putval(*fname, *aa, No, In_tarval);
X tarfiled(name, *aa);
X }
X return Yes;
X }
X}
X
X/***************************** Values on files ****************************/
X
XVisible value getval(fname, ct) value fname; literal ct; {
X char *buf; int k; parsetree w, code= NilTree; value v= Vnil;
X ifile= fopen(strval(fname), "r");
X if (ifile) {
X txptr fcol_save= first_col, tx_save= tx; context c;
X sv_context(&c);
X cntxt= ct;
X buf= (char *) getmem((unsigned)(f_size(ifile)+2)*sizeof(char));
X first_col= tx= ceol= buf;
X while ((k= getc(ifile)) != EOF)
X if (k != '\n') *ceol++= k;
X *ceol= '\n';
X fclose(ifile); vs_ifile();
X w= expr(ceol);
X if (still_ok) fix_nodes(&w, &code);
X curline= w; curlino= one;
X v= evalthread(code);
X if (!env_ok(v)) {
X release(v);
X v= Vnil;
X }
X curline= Vnil;
X release(w);
X freemem((ptr) buf);
X set_context(&c);
X first_col= fcol_save; tx= tx_save;
X } else {
X interr(CANT_READ);
X vs_ifile();
X }
X return v;
X}
X
XHidden bool env_ok(v) value v; {
X if (cntxt == In_prmnv || cntxt == In_wsgroup) {
X if (!Is_table(v)) {
X interr(MESS(4019, "value is not a table"));
X return No;
X }
X else if (!Is_ELT(v) && !Is_text(*key(v, 0))) {
X interr(MESS(4020, "in t[k], k is not a text"));
X return No;
X }
X }
X return Yes;
X}
X
XVisible bool permchanges;
X
XVisible Procedure initperm() {
X if (F_exists(permfile)) {
X value fn, name;
X intlet k, len;
X value v, pname;
X
X fn= mk_text(permfile);
X v= getval(fn, In_prmnv);
X release(fn);
X if (Valid(v)) {
X release(b_perm);
X b_perm= v;
X }
X len= length(b_perm);
X for (k= 0; k < len; k++) {
X pname= *key(b_perm, k);
X if (Permtype(pname) == Tar) {
X name= Permname(pname);
X tarfiled(name, Vnil);
X release(name);
X }
X }
X }
X permchanges= No;
X}
X
XVisible Procedure putval(fname, v, silently, ct) value fname, v;
X bool silently; literal ct; {
X value fn= copy(fname);
X FILE *fp;
X bool was_ok= still_ok;
X context c;
X
X sv_context(&c);
X cntxt= ct;
X curline= Vnil;
X curlino= one;
X#ifdef unix
X release(fn); fn= mk_text(tempfile);
X#endif
X fp= fopen(strval(fn), "w");
X if (fp != NULL) {
X redirect(fp);
X still_ok= Yes;
X wri(v, No, No, Yes); newline();
X f_close(fp);
X redirect(stdout);
X#ifdef unix
X if (still_ok) f_rename(fn, fname);
X#endif
X }
X else if (!silently) interrV(CANT_WRITE, fn);
X still_ok= was_ok;
X release(fn);
X set_context(&c);
X}
X
XVisible Procedure endperm() {
X static bool active;
X bool was_ok= still_ok;
X
X if (active)
X return;
X active= Yes;
X still_ok= Yes;
X put_targs();
X put_perm(b_perm);
X still_ok= was_ok;
X active= No;
X}
X
XHidden Procedure put_targs() {
X int k, len;
X value v, name;
X
X len= Valid(prmnv->tab) ? length(prmnv->tab) : 0;
X for (k= 0; k < len; k++) {
X v= copy(*assoc(prmnv->tab, k));
X name= copy(*key(prmnv->tab, k));
X if (!Is_filed(v)) {
X value fname= get_tfname(name);
X if (Valid(fname)) {
X release(errtname); errtname= copy(name);
X putval(fname, v, Yes, In_tarval);
X }
X release(fname);
X }
X tarfiled(name, Vnil);
X release(v); release(name);
X }
X}
X
XVisible Procedure put_perm(v) value v; {
X value fn;
X intlet len;
X
X if (!permchanges || !Valid(v))
X return;
X fn= mk_text(permfile);
X /* Remove the file if the permanent environment is empty */
X len= length(v);
X if (len == 0)
X f_delete(fn);
X else
X putval(fn, v, Yes, In_prmnv);
X release(fn);
X permchanges= No;
X}
X
XVisible Procedure clear_perm() {
X freeunits(USR_ALL);
X endperm();
X}
X
XVisible Procedure initsou() {
X release(b_units); b_units= mk_elt();
X release(last_unit); last_unit= mk_text(":");
X release(last_target); last_target= mk_text("=");
X release(b_perm); b_perm= mk_elt();
X}
X
XVisible Procedure endsou() {
X if (terminated)
X return; /* hack; to prevent seemingly endless QUIT */
X release(b_units); b_units= Vnil;
X release(b_perm); b_perm= Vnil;
X release(last_unit); last_unit= Vnil;
X release(last_target); last_target= Vnil;
X}
X
X/*
X * lst_uhds() displays the first line of the unit without a possible
X * present simple command
X */
X
X#define MORE MESS(4021, "Press [SPACE] for more, [RETURN] to exit list")
Xextern int winheight;
Xbool ask_for();
X
XVisible Procedure lst_uhds() {
X intlet k, len;
X value pname, *aa;
X how *u;
X int nprinted= 0;
X bool more= Yes;
X
X len= length(b_perm);
X for (k= 0; k<len && still_ok && more; ++k) {
X pname= *key(b_perm, k);
X if (!Is_text(pname) || Permtype(pname) == Tar)
X continue;
X /* reduce disk access: */
X if (u_exists(pname, &aa) && !Is_predefined(*aa))
X display(stdout, How_to(*aa)->unit, Yes);
X else
X lst_fileheading(*assoc(b_perm, k));
X fflush(stdout);
X if (++nprinted >= winheight) {
X more= ask_for(MORE);
X nprinted= 0;
X }
X }
X /* not interactive units */
X len= length(b_units);
X for (k= 0; k<len && still_ok && more; ++k) {
X u= How_to(*assoc(b_units, k));
X if (u -> filed == No && !p_exists(*key(b_units, k), &aa)) {
X display(stdout, u -> unit, Yes);
X fflush(stdout);
X if (++nprinted >= winheight) {
X more= ask_for(MORE);
X nprinted= 0;
X }
X }
X
X }
X}
X
XHidden Procedure lst_fileheading(v) value v; {
X FILE *fn;
X char *line;
X char *pcolon, *pc;
X
X if (!Is_text(v))
X return;
X fn= fopen(strval(v), "r");
X if (!fn)
X return;
X if ((line= f_getline(fn)) != NULL) {
X pcolon= strchr(line, C_COLON);
X if (pcolon != NULL) {
X pc= ++pcolon;
X while (Space(*pc)) ++pc;
X if (*pc != C_COMMENT && *pc != '\n') {
X /* single command after colon;
X * don't show it.
X */
X *(pcolon+1)= '\n';
X *(pcolon+2)= '\0';
X }
X }
X putstr(stdout, line);
X freestr(line);
X }
X fclose(fn);
X}
END_OF_FILE
if test 29957 -ne `wc -c <'abc/bint3/i3sou.c'`; then
echo shar: \"'abc/bint3/i3sou.c'\" unpacked with wrong size!
